package Net::DNS::Resolver::Base;
#
# $Id: Base.pm 329 2005-05-31 18:14:44Z olaf $
#

use strict;
use bytes;

use vars qw(
	    $VERSION
	    $has_inet6
	    $AUTOLOAD
);

use Carp;
use Config ();
use Socket;
use IO::Socket;
use IO::Select;

use Net::IP qw(ip_is_ipv4 ip_is_ipv6 ip_normalize); 
use Net::DNS;
use Net::DNS::Packet;

$VERSION = (qw$LastChangedRevision: 329 $)[1];


#
#  A few implementation notes wrt IPv6 support.
#
#  In general we try to be gracious to those stacks that do not have ipv6 support.
#  We test that by means of the availability of Socket6 and IO::Socket::INET6
#


#  We have chosen to not use mapped IPv4 addresses, there seem to be
#  issues with this; as a result we have to use sockets for both
#  family types.  To be able to deal with persistent sockets and
#  sockets of both family types we use an array that is indexed by the
#  socketfamily type to store the socket handlers. I think this could
#  be done more efficiently.

 
#  inet_pton is not available on WIN32, so we only use the getaddrinfo
#  call to translate IP addresses to socketaddress


 
#  Set the $force_inet4_only variable inside the BEGIN block to force
#  not to use the IPv6 stuff. You can use this for compatibility
#  test. We do not see a need to do this from the calling code.

 
# Olaf Kolkman, RIPE NCC, December 2003.
 
 
BEGIN {
    if ( 
	 eval {require Socket6;} &&
	 # INET6 prior to 2.01 will not work; sorry.
	 eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");}
	 ) {
 	import Socket6;
 	$has_inet6=1;
    }else{
 	$has_inet6=0;
    }
 }
	    
 
 
 
 
  
#
# Set up a closure to be our class data.
#
{
	my %defaults = (
		nameservers	   => ['127.0.0.1'],
		port		   => 53,
		srcaddr        => '0.0.0.0',
		srcport        => 0,
		domain	       => '',
		searchlist	   => [],
		retrans	       => 5,
		retry		   => 4,
		usevc		   => 0,
		stayopen       => 0,
		igntc          => 0,
		recurse        => 1,
		defnames       => 1,
		dnsrch         => 1,
		debug          => 0,
		errorstring	   => 'unknown error or no error',
		tsig_rr        => undef,
		answerfrom     => '',
		answersize     => 0,
		querytime      => undef,
		tcp_timeout    => 120,
		udp_timeout    => undef,
		axfr_sel       => undef,
		axfr_rr        => [],
		axfr_soa_count => 0,
		persistent_tcp => 0,
		persistent_udp => 0,
		dnssec         => 0,
		udppacketsize  => 0,  # The actual default is lower bound by Net::DNS::PACKETSZ
		cdflag         => 1,  # this is only used when {dnssec} == 1
		force_v4       => 0,  # force_v4 is only relevant when we have
                                      # v6 support available
		ignqrid        => 0,  # normally packets with non-matching ID 
                                      # or with the qr bit of are thrown away
			              # in 'ignqrid' these packets are 
			              # are accepted.
			              # USE WITH CARE, YOU ARE VULNARABLE TO
			              # SPOOFING IF SET.
			              # This is may be a temporary feature
	);
	
	# If we're running under a SOCKSified Perl, use TCP instead of UDP
	# and keep the sockets open.
	if ($Config::Config{'usesocks'}) {
		$defaults{'usevc'} = 1;
		$defaults{'persistent_tcp'} = 1;
	}
	
	sub defaults { \%defaults }
}

# These are the attributes that we let the user specify in the new().
# We also deprecate access to these with AUTOLOAD (some may be useful).
my %public_attr = map { $_ => 1 } qw(
	nameservers
	port
	srcaddr
	srcport
	domain
	searchlist
	retrans
	retry
	usevc
	stayopen
	igntc
	recurse
	defnames
	dnsrch
	debug
	tcp_timeout
	udp_timeout
	persistent_tcp
	persistent_udp
	dnssec
	ignqrid
);


sub new {
	my $class = shift;

	my $self = bless({ %{$class->defaults} }, $class);

	
	$self->_process_args(@_) if @_ and @_ % 2 == 0;
			
	return $self;
}



sub _process_args {
	my ($self, %args) = @_;
	
	if ($args{'config_file'}) {
		$self->read_config_file($args{'config_file'});
	}
	
	foreach my $attr (keys %args) {
		next unless $public_attr{$attr};
	
		if ($attr eq 'nameservers' || $attr eq 'searchlist') {
			die "Net::DNS::Resolver->new(): $attr must be an arrayref\n" unless
				UNIVERSAL::isa($args{$attr}, 'ARRAY');
		}
		
		if ($attr eq 'nameservers') {
			$self->nameservers(@{$args{$attr}});
		} else {
			$self->{$attr} = $args{$attr};
		}
	}


}
			
			
			


#
# Some people have reported that Net::DNS dies because AUTOLOAD picks up
# calls to DESTROY.
#
sub DESTROY {}


sub read_env {
	my ($invocant) = @_;
	my $config     = ref $invocant ? $invocant : $invocant->defaults;
		
	$config->{'nameservers'} = [ $ENV{'RES_NAMESERVERS'} =~ m/(\S+)/g ]
		if exists $ENV{'RES_NAMESERVERS'};

	$config->{'searchlist'}  = [ split(' ', $ENV{'RES_SEARCHLIST'})  ]
		if exists $ENV{'RES_SEARCHLIST'};
	
	$config->{'domain'} = $ENV{'LOCALDOMAIN'}
		if exists $ENV{'LOCALDOMAIN'};

	if (exists $ENV{'RES_OPTIONS'}) {
		foreach ($ENV{'RES_OPTIONS'} =~ m/(\S+)/g) {
			my ($name, $val) = split(m/:/);
			$val = 1 unless defined $val;
			$config->{$name} = $val if exists $config->{$name};
		}
	}
}

#
# $class->read_config_file($filename) or $self->read_config_file($file)
#
sub read_config_file {
	my ($invocant, $file) = @_;
	my $config            = ref $invocant ? $invocant : $invocant->defaults;

	
	my @ns;
	my @searchlist;
	
	local *FILE;

	open(FILE, "< $file") or croak "Could not open $file: $!";
	local $/ = "\n";
	local $_;
	
	while (<FILE>) {
 		s/\s*[;#].*//;
		
		# Skip ahead unless there's non-whitespace characters 
		next unless m/\S/;

		SWITCH: {
			/^\s*domain\s+(\S+)/ && do {
				$config->{'domain'} = $1;
				last SWITCH;
			};

			/^\s*search\s+(.*)/ && do {
				push(@searchlist, split(' ', $1));
				last SWITCH;
			};

			/^\s*nameserver\s+(.*)/ && do {
				foreach my $ns (split(' ', $1)) {
					$ns = '0.0.0.0' if $ns eq '0';
#					next if $ns =~ m/:/;  # skip IPv6 nameservers
					push @ns, $ns;
				}
				last SWITCH;
			};
		    }
		  }
		close FILE || croak "Could not close $file: $!";
		
		$config->{'nameservers'} = [ @ns ]         if @ns;
		$config->{'searchlist'}  = [ @searchlist ] if @searchlist;
	    }
 



sub print { print $_[0]->string }

sub string {
	my $self = shift;

	my $timeout = defined $self->{'tcp_timeout'} ? $self->{'tcp_timeout'} : 'indefinite';
	my $hasINET6line= $has_inet6 ?" (IPv6 Transport is available)":" (IPv6 Transport is not available)";
	my $ignqrid=$self->{'ignqrid'} ? "\n;; ACCEPTING ALL PACKETS (IGNQRID)":"";
	return <<END;
;; RESOLVER state:
;;  domain       = $self->{domain}
;;  searchlist   = @{$self->{searchlist}}
;;  nameservers  = @{$self->{nameservers}}
;;  port         = $self->{port}
;;  srcport      = $self->{srcport}
;;  srcaddr      = $self->{srcaddr}
;;  tcp_timeout  = $timeout
;;  retrans  = $self->{retrans}  retry    = $self->{retry}
;;  usevc    = $self->{usevc}  stayopen = $self->{stayopen}    igntc = $self->{igntc}
;;  defnames = $self->{defnames}  dnsrch   = $self->{dnsrch}
;;  recurse  = $self->{recurse}  debug    = $self->{debug}
;;  force_v4 = $self->{force_v4} $hasINET6line $ignqrid
END

}


sub searchlist {
	my $self = shift;
	$self->{'searchlist'} = [ @_ ] if @_;
	return @{$self->{'searchlist'}};
}

sub nameservers {
    my $self   = shift;
    my $defres = Net::DNS::Resolver->new;

    if (@_) {
	my @a;
	foreach my $ns (@_) {
	    if ($ns =~ /^(\d+(:?\.\d+){0,3})$/) {
		if ( ip_is_ipv4($ns) ) {
		    push @a, ($1 eq '0') ? '0.0.0.0' : $1;
		}
		
	    }
	    elsif ( ip_is_ipv6($ns) ) {
		push @a, ($ns eq '0') ? '::0' : $ns;
		
	    } else  {
		my @names;
		
		if ($ns !~ /\./) {
		    if (defined $defres->searchlist) {
			@names = map { $ns . '.' . $_ }
			$defres->searchlist;
		    } elsif (defined $defres->domain) {
			@names = ($ns . '.' . $defres->domain);
		    }
		}
		else {
		    @names = ($ns);
		}
		
		my $packet = $defres->search($ns);
		$self->errorstring($defres->errorstring);
		if (defined($packet)) {
		    push @a, cname_addr([@names], $packet);
		}
	    }
	}
	
	$self->{'nameservers'} = [ @a ];
    }
    my @returnval;
    foreach my $ns (@{$self->{'nameservers'}}){
	next if ip_is_ipv6($ns) && (! $has_inet6 || $self->force_v4() );
	push @returnval, $ns;
    }
    
    return @returnval;
}

sub nameserver { &nameservers }

sub cname_addr {
	my $names  = shift;
	my $packet = shift;
	my @addr;
	my @names = @{$names};

	my $oct2 = '(?:2[0-4]\d|25[0-5]|[0-1]?\d\d|\d)';

	RR: foreach my $rr ($packet->answer) {
		next RR unless grep {$rr->name} @names;
				
		if ($rr->type eq 'CNAME') {
			push(@names, $rr->cname);
		} elsif ($rr->type eq 'A') {
			# Run a basic taint check.
			next RR unless $rr->address =~ m/^($oct2\.$oct2\.$oct2\.$oct2)$/o;
			
			push(@addr, $1)
		}
	}
	
	
	return @addr;
}


# if ($self->{"udppacketsize"}  > Net::DNS::PACKETSZ() 
# then we use EDNS and $self->{"udppacketsize"} 
# should be taken as the maximum packet_data length
sub _packetsz {
	my ($self) = @_;

	return $self->{"udppacketsize"} > Net::DNS::PACKETSZ() ? 
		   $self->{"udppacketsize"} : Net::DNS::PACKETSZ(); 
}

sub _reset_errorstring {
	my ($self) = @_;
	
	$self->errorstring($self->defaults->{'errorstring'});
}


sub search {
	my $self = shift;
	my ($name, $type, $class) = @_;
	my $ans;

	$type  ||= 'A';
	$class ||= 'IN';

	# If the name looks like an IP address then do an appropriate
	# PTR query.
	if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
		$name = "$4.$3.$2.$1.in-addr.arpa.";
		$type = 'PTR';
	}
	
	# pass IPv6 addresses right to query()
	if (index($name, ':') > 0 and index($name, '.') < 0) {
		return $self->query($name);
	}

	# If the name contains at least one dot then try it as is first.
	if (index($name, '.') >= 0) {
		print ";; search($name, $type, $class)\n" if $self->{'debug'};
		$ans = $self->query($name, $type, $class);
		return $ans if $ans and $ans->header->ancount;
	}

	# If the name doesn't end in a dot then apply the search list.
	if (($name !~ /\.$/) && $self->{'dnsrch'}) {
		foreach my $domain (@{$self->{'searchlist'}}) {
			my $newname = "$name.$domain";
			print ";; search($newname, $type, $class)\n"
				if $self->{'debug'};
			$ans = $self->query($newname, $type, $class);
			return $ans if $ans and $ans->header->ancount;
		}
	}

	# Finally, if the name has no dots then try it as is.
	if (index($name, '.') < 0) {
		print ";; search($name, $type, $class)\n" if $self->{'debug'};
		$ans = $self->query("$name.", $type, $class);
		return $ans if $ans and $ans->header->ancount;
	}

	# No answer was found.
	return undef;
}


sub query {
	my ($self, $name, $type, $class) = @_;

	$type  ||= 'A';
	$class ||= 'IN';

	# If the name doesn't contain any dots then append the default domain.
	if ((index($name, '.') < 0) && (index($name, ':') < 0) && $self->{'defnames'}) {
		$name .= ".$self->{domain}";
	}

	# If the name looks like an IP address then do an appropriate
	# PTR query.
	if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
		$name = "$4.$3.$2.$1.in-addr.arpa";
		$type = 'PTR';
	}

	# IPv4 address in IPv6 format (very lax regex)
	if ($name =~ /^[0:]*:ffff:(\d+)\.(\d+)\.(\d+)\.(\d+)$/i) {
		$name = "$4.$3.$2.$1.in-addr.arpa";
		$type = 'PTR';
	}
	
	# if the name looks like an IPv6 0-compressed IP address then expand
	# PTR query. (eg 2001:5c0:0:1::2)
	if ($name =~ /::/) {
		# avoid stupid "Use of implicit split to @_ is deprecated" warning
		while (scalar(my @parts = split (/:/, $name)) < 8) {
			$name =~ s/::/:0::/;
		}
		$name =~ s/::/:0:/;
	}	
	
	# if the name looks like an IPv6 address then do appropriate
	# PTR query. (eg 2001:5c0:0:1:0:0:0:2)
	if ($name =~ /:/) {
		my (@stuff) = split (/:/, $name);
		if (@stuff == 8) {
			$name = 'ip6.arpa.';
			$type = 'PTR';
			foreach my $segment (@stuff) {
				$segment = sprintf ("%04s", $segment);
				$segment =~ m/(.)(.)(.)(.)/;
				$name = "$4.$3.$2.$1.$name";
			}
		} else {
			# no idea what this is
		}
	}

	print ";; query($name, $type, $class)\n" if $self->{'debug'};
	my $packet = Net::DNS::Packet->new($name, $type, $class);

	my $ans = $self->send($packet);

	return $ans && $ans->header->ancount   ? $ans : undef;
}


sub send {
	my $self = shift;
	my $packet = $self->make_query_packet(@_);
	my $packet_data = $packet->data;


	my $ans;

	if ($self->{'usevc'} || length $packet_data > $self->_packetsz) {
	  
	    $ans = $self->send_tcp($packet, $packet_data);
	    
	} else {
	    $ans = $self->send_udp($packet, $packet_data);
	    if ($ans && $ans->header->tc && !$self->{'igntc'}) {
			print ";;\n;; packet truncated: retrying using TCP\n" if $self->{'debug'};
			$ans = $self->send_tcp($packet, $packet_data);
	    }
	}
	
	return $ans;
}



sub send_tcp {
	my ($self, $packet, $packet_data) = @_;

	my $lastanswer;

	unless ( $self->nameservers()) {
		$self->errorstring('no nameservers');
		print ";; ERROR: send_tcp: no nameservers\n" if $self->{'debug'};
		return;
	}

	$self->_reset_errorstring;
	my $timeout = $self->{'tcp_timeout'};

	NAMESERVER: foreach my $ns ($self->nameservers()) {
		my $srcport = $self->{'srcport'};
		my $srcaddr = $self->{'srcaddr'};
		my $dstport = $self->{'port'};

		print ";; attempt to send_tcp($ns:$dstport) (src port = $srcport)\n"
			if $self->{'debug'};



		my $sock;
		my $sock_key = "$ns:$dstport";
		my ($host,$port);
		if ($self->persistent_tcp && $self->{'sockets'}{$sock_key}) {
			$sock = $self->{'sockets'}{$sock_key};
			print ";; using persistent socket\n"
				if $self->{'debug'};
		} else {
		    # IO::Socket carps on errors if Perl's -w flag is
		    # turned on.  Uncomment the next two lines and the
		    # line following the "new" call to turn off these
		    # messages.
		    
		    #my $old_wflag = $^W;
		    #$^W = 0;
		    if ($has_inet6 && ! $self->force_v4()){
			$srcaddr="0" if $srcaddr eq "0.0.0.0";  # Otherwise the INET6 socket will just fail
			
			$sock = 
			    IO::Socket::INET6->new(
						   PeerPort =>    53,
						   PeerAddr =>    $ns,
						   LocalAddr => 0,
						   LocalPort => ($srcport || undef),
						   Proto     => 'tcp',
						   Timeout   => $timeout,
						   );
			
		    }else{
			$sock = IO::Socket::INET->new(
						      PeerAddr  => $ns,
						      PeerPort  => $dstport,
						      LocalAddr => $srcaddr,
						      LocalPort => ($srcport || undef),
						      Proto     => 'tcp',
						      Timeout   => $timeout
						      )
		    }
		    
		    #$^W = $old_wflag;
		    
		    unless ($sock) {
			$self->errorstring('connection failed');
			print ';; ERROR: send_tcp: connection ',
			"failed: $!\n" if $self->{'debug'};
			next;
		    }

			$self->{'sockets'}{$sock_key} = $sock;
		}

		my $lenmsg = pack('n', length($packet_data));
		print ';; sending ', length($packet_data), " bytes\n"
			if $self->{'debug'};

		# note that we send the length and packet data in a single call
		# as this produces a single TCP packet rather than two. This
		# is more efficient and also makes things much nicer for sniffers.
		# (ethereal doesn't seem to reassemble DNS over TCP correctly)


		unless ($sock->send( $lenmsg . $packet_data)) {
			$self->errorstring($!);
			print ";; ERROR: send_tcp: data send failed: $!\n"
				if $self->{'debug'};
			next;
		}

		my $sel = IO::Select->new($sock);

		if ($sel->can_read($timeout)) {
			my $buf = read_tcp($sock, Net::DNS::INT16SZ(), $self->{'debug'});
			next unless length($buf);
			my ($len) = unpack('n', $buf);
			next unless $len;

			unless ($sel->can_read($timeout)) {
				$self->errorstring('timeout');
				print ";; TIMEOUT\n" if $self->{'debug'};
				next;
			}

			$buf = read_tcp($sock, $len, $self->{'debug'});

			$self->answerfrom($sock->peerhost);
			$self->answersize(length $buf);

			print ';; received ', length($buf), " bytes\n"
				if $self->{'debug'};

			unless (length($buf) == $len) {
				$self->errorstring("expected $len bytes, " .
						   'received ' . length($buf));
				next;
			}

			my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
			if (defined $ans) {
				$self->errorstring($ans->header->rcode);
				$ans->answerfrom($self->answerfrom);
				$ans->answersize($self->answersize);

				if ($ans->header->rcode ne "NOERROR" &&
				    $ans->header->rcode ne "NXDOMAIN"){
					# Remove this one from the stack
					print "RCODE: ".$ans->header->rcode ."; tying next nameserver\n" if $self->{'debug'};
					$lastanswer=$ans;
					next NAMESERVER ;
					
				}

			}
			elsif (defined $err) {
				$self->errorstring($err);
			}

			return $ans;
		}
		else {
			$self->errorstring('timeout');
			next;
		}
	}

	if ($lastanswer){
		$self->errorstring('RCODE: '.$lastanswer->header->rcode );
		return $lastanswer;

	}

	return;
}



sub send_udp {
	my ($self, $packet, $packet_data) = @_;
	my $retrans = $self->{'retrans'};
	my $timeout = $retrans;
	
	my $lastanswer;

	my $stop_time = time + $self->{'udp_timeout'} if $self->{'udp_timeout'};
	
	$self->_reset_errorstring;
	
 	my @ns;
  	my $dstport = $self->{'port'};
  	my $srcport = $self->{'srcport'};
  	my $srcaddr = $self->{'srcaddr'};
	
 	my @sock;
	
	
 	if ($self->persistent_udp){
 	    if ($has_inet6 && ! $self->force_v4()){
 		if ( $self->{'sockets'}[AF_INET6]{'UDP'}) {
 		    $sock[AF_INET6] = $self->{'sockets'}[AF_INET6]{'UDP'};
 		    print ";; using persistent AF_INET6 family type socket\n"
			if $self->{'debug'};
 		}
 	    }
 	    if ( $self->{'sockets'}[AF_INET]{'UDP'}) {
 		$sock[AF_INET] = $self->{'sockets'}[AF_INET]{'UDP'};
 		print ";; using persistent AF_INET6 family type socket\n"
 		    if $self->{'debug'};
 	    }
 	    
	    
	} else {
	    if ($has_inet6  && ! $self->force_v4()){
 		$srcaddr="0" if $srcaddr eq "0.0.0.0";  # Otherwise the INET6 socket will just fail
		
		# IO::Socket carps on errors if Perl's -w flag is turned on.
		# Uncomment the next two lines and the line following the "new"
		# call to turn off these messages.
		
		#my $old_wflag = $^W;
		#$^W = 0;
		
 		$sock[AF_INET6] = IO::Socket::INET6->new(
 							 LocalAddr => $srcaddr,
 							 LocalPort => ($srcport || undef),
 							 Proto     => 'udp',
 							 );
 		


 		#$^W = $old_wflag;
 	    }

 	    #always create an AF_INET family type socket.
 	    
 	    #my $old_wflag = $^W;
 	    #$^W = 0;
 	    
 	    $sock[AF_INET] = IO::Socket::INET->new(
 						   LocalAddr => $srcaddr,
 						   LocalPort => ($srcport || undef),
 						   Proto     => 'udp',
 						   ) ;
 	    
 	    #$^W = $old_wflag;
 	    
 	    

  
 
 	    unless (defined $sock[AF_INET] || defined $sock[AF_INET6]) {
 		$self->errorstring("could not get socket");   #'
 		return;
 	    }
 
 	    
 	    $self->{'sockets'}[AF_INET]{'UDP'} = $sock[AF_INET] if ($self->persistent_udp) && defined( $sock[AF_INET] );
 	    $self->{'sockets'}[AF_INET6]{'UDP'} = $sock[AF_INET6] if $has_inet6 && ($self->persistent_udp) && defined( $sock[AF_INET6] && ! $self->force_v4() );
 	    
	    
	}
	
	
 	# Constructing an array of arrays that contain 3 elements: The
 	# nameserver IP address, its sockaddr and the sockfamily for
 	# which the sockaddr structure is constructed.
	
      NSADDRESS: foreach my $ns_address ($self->nameservers()){
	  # The logic below determines the $dst_sockaddr.
	  # If getaddrinfo is available that is used for both INET4 and INET6
	  # If getaddrinfo is not avialable (Socket6 failed to load) we revert
	  # to the 'classic mechanism
	  if ($has_inet6  && ! $self->force_v4()){ 
	      # we can use getaddrinfo
	      no strict 'subs';   # Because of the eval statement in the BEGIN
	      # AI_NUMERICHOST is not available at compile time.
	      
	      # The AI_NUMERICHOST surpresses lookups.
	      
	      
	      my $old_wflag = $^W; 		#circumvent perl -w warnings about 'udp'
	      $^W = 0;
	      
	      my @res = getaddrinfo($ns_address, $dstport, AF_UNSPEC, SOCK_DGRAM, 
				    'udp', AI_NUMERICHOST);
	      
	      $^W=$old_wflag ;
	      
	      
	      use strict 'subs';
	      
	      my ($sockfamily, $socktype_tmp, 
		  $proto_tmp, $dst_sockaddr, $canonname_tmp) = @res;
	      
	      if (scalar(@res) < 5) {
		  die ("can't resolve \"$ns_address\" to address");
	      }
	      
	      push @ns,[$ns_address,$dst_sockaddr,$sockfamily];
	      
	  }else{
	      next NSADDRESS unless( ip_is_ipv4($ns_address));
	      my $dst_sockaddr = sockaddr_in($dstport, inet_aton($ns_address));
	      push @ns, [$ns_address,$dst_sockaddr,AF_INET];
	  }
	  
      }

      	unless (@ns) {
	    $self->errorstring('no nameservers');
	    return;
	}

 	my $sel = IO::Select->new() ;
	# We allready tested that one of the two socket exists

 	$sel->add($sock[AF_INET]) if defined ($sock[AF_INET]);
 	$sel->add($sock[AF_INET6]) if $has_inet6 &&  defined ($sock[AF_INET6]) && ! $self->force_v4();
	

	# Perform each round of retries.
	for (my $i = 0;
	     $i < $self->{'retry'};
	     ++$i, $retrans *= 2, $timeout = int($retrans / (@ns || 1))) {

		$timeout = 1 if ($timeout < 1);
		
		# Try each nameserver.
	      NAMESERVER: foreach my $ns (@ns) {
			if ($stop_time) {
				my $now = time;
				if ($stop_time < $now) {
					$self->errorstring('query timed out');
					return;
				}
				if ($timeout > 1 && $timeout > ($stop_time-$now)) {
					$timeout = $stop_time-$now;
				}
			}
			my $nsname = $ns->[0];
			my $nsaddr = $ns->[1];
			my $nssockfamily = $ns->[2];

			# If we do not have a socket for the transport
			# we are supposed to reach the namserver on we
			# should skip it.
			unless (defined ($sock[ $nssockfamily ])){
			    $self->errorstring("Send error: cannot reach $nsname (" .
					       ( ($nssockfamily == AF_INET6) ? "IPv6" : "" ).
					       ( ($nssockfamily == AF_INET) ? "IPv4" : "" ).
					       ") not available"

);
			    next NAMESERVER ;
			    }

			print ";; send_udp($nsname:$dstport)\n"
				if $self->{'debug'};

			unless ($sock[$nssockfamily]->send($packet_data, 0, $nsaddr)) {
				print ";; send error: $!\n" if $self->{'debug'};
				$self->errorstring("Send error: $!");
				@ns = grep { $_->[0] ne $nsname } @ns;
				next;
			}

			# See ticket 11931 but this works not quite yet
			my $oldpacket_timeout=time+$timeout;
			until ( $oldpacket_timeout && ($oldpacket_timeout < time())) {
			    my @ready = $sel->can_read($timeout);
			  SELECTOR: foreach my $ready (@ready) {
			      my $buf = '';
			      
			      if ($ready->recv($buf, $self->_packetsz)) {
				  
				  $self->answerfrom($ready->peerhost);
				  $self->answersize(length $buf);
				  
				  print ';; answer from ',
				  $ready->peerhost, ':',
				  $ready->peerport, ' : ',
				  length($buf), " bytes\n"
				      if $self->{'debug'};
				  
				  my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
				  
				  if (defined $ans) {
				      next SELECTOR unless ( $ans->header->qr || $self->{'ignqrid'});
				      next SELECTOR unless  ( ($ans->header->id == $packet->header->id) || $self->{'ignqrid'} );
				      $self->errorstring($ans->header->rcode);
				      $ans->answerfrom($self->answerfrom);
				      $ans->answersize($self->answersize);
				      if ($ans->header->rcode ne "NOERROR" &&
					  $ans->header->rcode ne "NXDOMAIN"){
					  # Remove this one from the stack
					  @ns = grep { $_->[0] ne $ready->peerhost } @ns;
					  print "RCODE: ".$ans->header->rcode ."; tying next nameserver\n" if $self->{'debug'};
					  $lastanswer=$ans;
					  next NAMESERVER ;
					  
				      }
				  } elsif (defined $err) {
				      $self->errorstring($err);
				  }
				  
				  return $ans;
			      } else {
				  $self->errorstring($!);
				  
				  print ';; recv ERROR(',
				  $ready->peerhost, ':',
				  $ready->peerport, '): ',
				  $self->errorstring, "\n"
				      if $self->{'debug'};
				  
				  @ns = grep { $_->[0] ne $ready->peerhost } @ns;
				  
				  return unless @ns;
			      }
			  } #SELECTOR LOOP
			} # until stop_time loop
		    } #NAMESERVER LOOP
		
	}
	
	if ($lastanswer){
		$self->errorstring('RCODE: '.$lastanswer->header->rcode );
		return $lastanswer;

	}
	if ($sel->handles) {
	    # If there are valid hanndles than we have either a timeout or 
	    # a send error.
	    $self->errorstring('query timed out') unless ($self->errorstring =~ /Send error:/);
	}
	else {
		$self->errorstring('all nameservers failed');
	}
	return;
}


sub bgsend {
	my $self = shift;

	unless ($self->nameservers()) {
		$self->errorstring('no nameservers');
		return;
	}

		$self->_reset_errorstring;

	my $packet = $self->make_query_packet(@_);
	my $packet_data = $packet->data;

	my $srcaddr = $self->{'srcaddr'};
	my $srcport = $self->{'srcport'};


	my (@res, $sockfamily, $dst_sockaddr);
	my $ns_address = ($self->nameservers())[0];
	my $dstport = $self->{'port'};


	# The logic below determines ther $dst_sockaddr.
	# If getaddrinfo is available that is used for both INET4 and INET6
	# If getaddrinfo is not avialable (Socket6 failed to load) we revert
	# to the 'classic mechanism
	if ($has_inet6  && ! $self->force_v4()){ 

	    my ( $socktype_tmp, $proto_tmp, $canonname_tmp);

	    no strict 'subs';   # Because of the eval statement in the BEGIN
	                      # AI_NUMERICHOST is not available at compile time.

	    # The AI_NUMERICHOST surpresses lookups.
	    my @res = getaddrinfo($ns_address, $dstport, AF_UNSPEC, SOCK_DGRAM, 
				  'udp', AI_NUMERICHOST);

	    use strict 'subs';

	    ($sockfamily, $socktype_tmp, 
	     $proto_tmp, $dst_sockaddr, $canonname_tmp) = @res;

	    if (scalar(@res) < 5) {
		die ("can't resolve \"$ns_address\" to address (it have been an IP address)");
	    }

	}else{
	    $sockfamily=AF_INET;
	    
	    if (! ip_is_ipv4($ns_address)){
		$self->errorstring("bgsend(ipv4 only):$ns_address does not seem to be a valid IPv4 address");
		return;
	    }

	    $dst_sockaddr = sockaddr_in($dstport, inet_aton($ns_address));



	}
	my @socket;  

	if ($sockfamily == AF_INET) {
	    $socket[$sockfamily] = IO::Socket::INET->new(
							 Proto => 'udp',
							 Type => SOCK_DGRAM,
							 LocalAddr => $srcaddr,
							 LocalPort => $srcport,
					    );
	} elsif ($sockfamily == AF_INET6 ) {
	    $srcaddr="0" if $srcaddr eq "0.0.0.0";  # Otherwise the INET6 socket will just fail
	    $socket[$sockfamily] = IO::Socket::INET6->new(
							  Proto => 'udp',
							  Type => SOCK_DGRAM,
							  LocalAddr => $srcaddr,
							  LocalPort => $srcport,
					     );
	} else {
	    die ref($self)." bgsend:Unsoported Socket Family: $sockfamily";
	}
	
	unless (scalar(@socket)) {
		$self->errorstring("could not get socket");   #'
		return;
	}








	print ";; bgsend($ns_address : $dstport)\n" if $self->{'debug'};
	print ";; remote addr struc: ".unpack("H*", $dst_sockaddr)."\n";

	foreach my $socket (@socket){
	    next if !defined $socket;
	    
	    unless ($socket->send($packet_data,0,$dst_sockaddr)){
		my $err = $!;
		print ";; send ERROR($ns_address): $err\n" if $self->{'debug'};
		
		$self->errorstring("Send: ".$err);
		return;
	    }
	    return $socket;
	}
	$self->errorstring("Could not find a socket to send on");
	return;
	    
}

sub bgread {
	my ($self, $sock) = @_;

	my $buf = '';

	my $peeraddr = $sock->recv($buf, $self->_packetsz);
	
	if ($peeraddr) {
		print ';; answer from ', $sock->peerhost, ':',
		      $sock->peerport, ' : ', length($buf), " bytes\n"
			if $self->{'debug'};

		my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
		
		if (defined $ans) {
			$self->errorstring($ans->header->rcode);
		} elsif (defined $err) {
			$self->errorstring($err);
		}
		
		return $ans;
	} else {
		$self->errorstring($!);
		return;
	}
}

sub bgisready {
	my $self = shift;
	my $sel = IO::Select->new(@_);
	my @ready = $sel->can_read(0.0);
	return @ready > 0;
}

sub make_query_packet {
	my $self = shift;
	my $packet;

	if (ref($_[0]) and $_[0]->isa('Net::DNS::Packet')) {
		$packet = shift;
	} else {
		my ($name, $type, $class) = @_;

		$name  ||= '';
		$type  ||= 'A';
		$class ||= 'IN';

		# If the name looks like an IP address then do an appropriate
		# PTR query.
		if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
			$name = "$4.$3.$2.$1.in-addr.arpa.";
			$type = 'PTR';
		}

		$packet = Net::DNS::Packet->new($name, $type, $class);
	}

	if ($packet->header->opcode eq 'QUERY') {
		$packet->header->rd($self->{'recurse'});
	}

    if ($self->{'dnssec'}) {
	    # RFC 3225
    	print ";; Adding EDNS extention with UDP packetsize $self->{'udppacketsize'} and DNS OK bit set\n" 
    		if $self->{'debug'};
    	
    	my $optrr = Net::DNS::RR->new(
						Type         => 'OPT',
						Name         => '',
						Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
						ednsflags    => 0x8000, # first bit set see RFC 3225 
				   );
				 
	    $packet->push('additional', $optrr);
	    
	} elsif ($self->{'udppacketsize'} > Net::DNS::PACKETSZ()) {
	    print ";; Adding EDNS extention with UDP packetsize  $self->{'udppacketsize'}.\n" if $self->{'debug'};
	    # RFC 3225
	    my $optrr = Net::DNS::RR->new( 
						Type         => 'OPT',
						Name         => '',
						Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
						TTL          => 0x0000 # RCODE 32bit Hex
				    );
				    
	    $packet->push('additional', $optrr);
	}
	

	if ($self->{'tsig_rr'}) {
		if (!grep { $_->type eq 'TSIG' } $packet->additional) {
			$packet->push('additional', $self->{'tsig_rr'});
		}
	}

	return $packet;
}

sub axfr {
	my $self = shift;
	my @zone;

	if ($self->axfr_start(@_)) {
		my ($rr, $err);
		while (($rr, $err) = $self->axfr_next, $rr && !$err) {
			push @zone, $rr;
		}
		@zone = () if $err;
	}

	return @zone;
}

sub axfr_old {
	croak "Use of Net::DNS::Resolver::axfr_old() is deprecated, use axfr() or axfr_start().";
}

sub axfr_start {
	my $self = shift;
	my ($dname, $class) = @_;
	$dname ||= $self->{'searchlist'}->[0];
	$class ||= 'IN';

	unless ($dname) {
		print ";; ERROR: axfr: no zone specified\n" if $self->{'debug'};
		$self->errorstring('no zone');
		return;
	}

	print ";; axfr_start($dname, $class)\n" if $self->{'debug'};

	unless ($self->nameservers()) {
		$self->errorstring('no nameservers');
		print ";; ERROR: no nameservers\n" if $self->{'debug'};
		return;
	}

	my $packet = $self->make_query_packet($dname, 'AXFR', $class);
	my $packet_data = $packet->data;

	my $ns = ($self->nameservers())[0];

	print ";; axfr_start nameserver = $ns\n" if $self->{'debug'};

	my $srcport = $self->{'srcport'};
	my $srcaddr = $self->{'srcaddr'};
	my $dstport = $self->{'port'};

	my $sock;
	my $sock_key = "$ns:$self->{'port'}";

	if ($self->{'persistent_tcp'} && $self->{'sockets'}->{$sock_key}) {
	    $sock = $self->{'sockets'}->{$sock_key};
	    print ";; using persistent socket\n" if $self->{'debug'};
	    
	} else {
	    
	    
	    if ($has_inet6  && ! $self->force_v4()){
		$srcaddr="0" if $srcaddr eq "0.0.0.0";  # Otherwise the INET6 socket will just fail
		
		$sock = 
		    IO::Socket::INET6->new(
					   PeerPort =>    53,
					   PeerAddr =>    $ns,
					   LocalAddr => 0,
					   LocalPort => ($srcport || undef),
					   Proto     => 'tcp',
					   );
		
	    }else{
		$sock = IO::Socket::INET->new(
					      PeerAddr  => $ns,
					      PeerPort  => $dstport,
					      LocalAddr => $srcaddr,
					      LocalPort => ($srcport || undef),
					      Proto     => 'tcp',
					      );
	    }
	    
	    #$^W = $old_wflag;
	    
	    unless ($sock) {
		$self->errorstring('connection failed');
		print ';; ERROR: send_tcp: connection ',
		"failed: $!\n" if $self->{'debug'};
		next;
	    }
	    
	    $self->{'sockets'}{$sock_key} = $sock;
	}


	my $lenmsg = pack('n', length($packet_data));

	unless ($sock->send($lenmsg)) {
		$self->errorstring($!);
		return;
	}

	unless ($sock->send($packet_data)) {
		$self->errorstring($!);
		return;
	}

	my $sel = IO::Select->new($sock);

	$self->{'axfr_sel'}       = $sel;
	$self->{'axfr_rr'}        = [];
	$self->{'axfr_soa_count'} = 0;

	return $sock;
}


sub axfr_next {
	my $self = shift;
	my $err  = '';
	
	unless (@{$self->{'axfr_rr'}}) {
		unless ($self->{'axfr_sel'}) {
			my $err = 'no zone transfer in progress';
			
			print ";; $err\n" if $self->{'debug'};
			$self->errorstring($err);
					
			return wantarray ? (undef, $err) : undef;
		}

		my $sel = $self->{'axfr_sel'};
		my $timeout = $self->{'tcp_timeout'};

		#--------------------------------------------------------------
		# Read the length of the response packet.
		#--------------------------------------------------------------

		my @ready = $sel->can_read($timeout);
		unless (@ready) {
			$err = 'timeout';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my $buf = read_tcp($ready[0], Net::DNS::INT16SZ(), $self->{'debug'});
		unless (length $buf) {
			$err = 'truncated zone transfer';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my ($len) = unpack('n', $buf);
		unless ($len) {
			$err = 'truncated zone transfer';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		#--------------------------------------------------------------
		# Read the response packet.
		#--------------------------------------------------------------

		@ready = $sel->can_read($timeout);
		unless (@ready) {
			$err = 'timeout';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		$buf = read_tcp($ready[0], $len, $self->{'debug'});

		print ';; received ', length($buf), " bytes\n"
			if $self->{'debug'};

		unless (length($buf) == $len) {
			$err = "expected $len bytes, received " . length($buf);
			$self->errorstring($err);
			print ";; $err\n" if $self->{'debug'};
			return wantarray ? (undef, $err) : undef;
		}

		my $ans;
		($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});

		if ($ans) {
			if ($ans->header->rcode ne 'NOERROR') {	
				$self->errorstring('Response code from server: ' . $ans->header->rcode);
				print ';; Response code from server: ' . $ans->header->rcode . "\n" if $self->{'debug'};
				return wantarray ? (undef, $err) : undef;
			}
			if ($ans->header->ancount < 1) {
				$err = 'truncated zone transfer';
				$self->errorstring($err);
				print ";; $err\n" if $self->{'debug'};
				return wantarray ? (undef, $err) : undef;
			}
		}
		else {
			$err ||= 'unknown error during packet parsing';
			$self->errorstring($err);
			print ";; $err\n" if $self->{'debug'};
			return wantarray ? (undef, $err) : undef;
		}

		foreach my $rr ($ans->answer) {
			if ($rr->type eq 'SOA') {
				if (++$self->{'axfr_soa_count'} < 2) {
					push @{$self->{'axfr_rr'}}, $rr;
				}
			}
			else {
				push @{$self->{'axfr_rr'}}, $rr;
			}
		}

		if ($self->{'axfr_soa_count'} >= 2) {
			$self->{'axfr_sel'} = undef;
			# we need to mark the transfer as over if the responce was in 
			# many answers.  Otherwise, the user will call axfr_next again
			# and that will cause a 'no transfer in progress' error.
			push(@{$self->{'axfr_rr'}}, undef);
		}
	}

	my $rr = shift @{$self->{'axfr_rr'}};

	return wantarray ? ($rr, undef) : $rr;
}




sub dnssec {
    my ($self, $new_val) = @_;
    if (defined $new_val) {
	$self->{"dnssec"} = $new_val;
	# Setting the udppacket size to some higher default
	$self->udppacketsize(2048) if $new_val;
    }
    
    Carp::carp ("You called the Net::DNS::Resolver::dnssec() method but do not have Net::DNS::SEC installed") if $self->{"dnssec"} && ! $Net::DNS::DNSSEC;
    
    return $self->{"dnssec"};
};



sub tsig {
	my $self = shift;

	if (@_ == 1) {
		if ($_[0] && ref($_[0])) {
			$self->{'tsig_rr'} = $_[0];
		}
		else {
			$self->{'tsig_rr'} = undef;
		}
	}
	elsif (@_ == 2) {
		my ($key_name, $key) = @_;
		$self->{'tsig_rr'} = Net::DNS::RR->new("$key_name TSIG $key");
	}

	return $self->{'tsig_rr'};
}

#
# Usage:  $data = read_tcp($socket, $nbytes, $debug);
#
sub read_tcp {
	my ($sock, $nbytes, $debug) = @_;
	my $buf = '';

	while (length($buf) < $nbytes) {
		my $nread = $nbytes - length($buf);
		my $read_buf = '';

		print ";; read_tcp: expecting $nread bytes\n" if $debug;

		# During some of my tests recv() returned undef even
		# though there wasn't an error.  Checking for the amount
		# of data read appears to work around that problem.

		unless ($sock->recv($read_buf, $nread)) {
			if (length($read_buf) < 1) {
				my $errstr = $!;

				print ";; ERROR: read_tcp: recv failed: $!\n"
					if $debug;

				if ($errstr eq 'Resource temporarily unavailable') {
					warn "ERROR: read_tcp: recv failed: $errstr\n";
					warn "ERROR: try setting \$res->timeout(undef)\n";
				}

				last;
			}
		}

		print ';; read_tcp: received ', length($read_buf), " bytes\n"
			if $debug;

		last unless length($read_buf);
		$buf .= $read_buf;
	}

	return $buf;
}





sub AUTOLOAD {
	my ($self) = @_;

	my $name = $AUTOLOAD;
	$name =~ s/.*://;

	Carp::croak "$name: no such method" unless exists $self->{$name};
	
	no strict q/refs/;
	
	
	*{$AUTOLOAD} = sub {
		my ($self, $new_val) = @_;
		
		if (defined $new_val) {
			$self->{"$name"} = $new_val;
		}
		
		return $self->{"$name"};
	};

	
	goto &{$AUTOLOAD};	
}

1;

__END__

=head1 NAME

Net::DNS::Resolver::Base - Common Resolver Class

=head1 SYNOPSIS

 use base qw/Net::DNS::Resolver::Base/;

=head1 DESCRIPTION

This class is the common base class for the different platform
sub-classes of L<Net::DNS::Resolver|Net::DNS::Resolver>.  

No user serviceable parts inside, see L<Net::DNS::Resolver|Net::DNS::Resolver>
for all your resolving needs.

=head1 COPYRIGHT

Copyright (c) 1997-2002 Michael Fuhr. 

Portions Copyright (c) 2002-2004 Chris Reinhardt.

Portions Copyright (c) 2005 Olaf Kolkman  <olaf@net-dns.org>

All rights reserved.  This program is free software; you may redistribute
it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<perl(1)>, L<Net::DNS>, L<Net::DNS::Resolver>

=cut


